﻿namespace FML

#light

// identity monad
module Monoid =

 type Monoid<'a> = interface
    abstract Empty: unit -> 'a
    abstract Append : 'a -> 'a -> 'a
 end

 
 type ListMonoid<'a>() = class end
     with interface Monoid<'a list> with
                 member s.Empty() = []
                 member s.Append a b = a @ b

module IdentityM =

 type IdentityMonad = interface
    abstract Bind : 'a * ('a -> 'b) -> 'b
    abstract Let : 'a * ('a -> 'b) -> 'b
    abstract Return : 'a -> 'a
    abstract Delay : f:(unit -> 'a) -> 'a
    abstract Map : f:('a -> 'b) * 'a -> 'b 
    abstract Join : m : 'a -> 'a  
 end


 type IdentityBuilder() = class end
   with interface IdentityMonad with
         member s.Bind(a, f) =   f a
         member s.Let(a, f) =  f a
         member s.Return a = a
         member s.Delay f = f()
         member s.Map(f, m) = (s:>IdentityMonad).Bind(m, f)
         member s.Join(m) = (s:>IdentityMonad).Map(id, m)
  end
    
 let identityM = new  IdentityBuilder() :> IdentityMonad

// option monad

module OptionM =

 type IOptionMonad = interface
    abstract Bind : 'a option * ('a -> 'b option) -> 'b option
    abstract Let : 'a option * ('a -> 'b option) -> 'b option
    abstract Return : 'a -> 'a option
    abstract Delay : f:(unit -> 'a option) -> 'a option
    abstract Zero : unit -> 'a option 
    abstract Map : ('a -> 'b) * 'a option -> 'b option
    abstract Join : 'a option option -> 'a option
    abstract Sequence : 'a option list  -> 'a list option
    abstract MapM : ('a -> 'b option) * 'a list -> 'b list option
    abstract Sequence_ : 'a option list  -> unit option 
    abstract MapM_ :('a -> 'b option) * 'a list -> unit option
 end


 type OptionBuilder() = class end
   with interface IOptionMonad with
         member s.Bind(a, f) =   match a with
                                 |Some v -> f v
                                 |None -> None
         member s.Let(a, f) =  match a with
                               |Some v -> f v
                               |None -> None
         member s.Return a = Some a
         member s.Delay f = f()
         member s.Zero() = None
         member s.Map(f, m) = (s:>IOptionMonad) { let! a = m
                                                  return f a
                                                }
         member s.Join(m) = (s:>IOptionMonad).Bind(m, id)
         member s.Sequence(m) = let optionM = new OptionBuilder() :>IOptionMonad
                                List.foldBack (fun e s -> optionM { let! e' = e
                                                                    let! s' = s
                                                                    return (e' :: s')
                                                                  } ) m (optionM.Return([])) 
         member s.Sequence_ m = let optionM = new OptionBuilder() :>IOptionMonad
                                List.foldBack (fun e s -> optionM { let! e' = e
                                                                    return! s
                                                                  } ) m (optionM.Return(()))
         member s.MapM(f, m) = (s:>IOptionMonad).Sequence(List.map f m)
         member s.MapM_(f, m) = (s:>IOptionMonad).Sequence_(List.map f m)


 let optionM = new  OptionBuilder() :> IOptionMonad

// list monad

module ListM =

 type IListMonad = interface
    abstract Bind : 'a list * ('a -> 'b list) -> 'b list
    abstract Let : 'a list * ('a -> 'b list) -> 'b list
    abstract Return : 'a -> 'a list
    abstract Delay : f:(unit -> 'a list) -> 'a list
    abstract Zero : unit -> 'a list 
    abstract Map :  ('a -> 'b) * 'a list -> 'b list
    abstract Join :  'a list list -> 'a list
 end

 type ListBuilder() = class end
    with interface IListMonad with
                member s.Bind(a, f) =  List.concat (List.map f a)
                member s.Let(a, f) =  List.concat (List.map f a)
                member s.Return a = [a]
                member s.Delay f = f()
                member s.Zero() = []
                member s.Map(f, m) =  (s:>IListMonad) { let! a = m
                                                        return f a
                                                      }
                member s.Join(m) =  (s:>IListMonad).Bind(m, id)
    
 let listM = new ListBuilder() :> IListMonad
   

// state monad

module StateM =

 type State<'a, 'state> = State of ('state -> ('a * 'state) )

 type IStateMonad = interface
    abstract Bind : State<'a, 'state> * ('a ->  State<'b, 'state>) -> State<'b, 'state>
    abstract Let :  'a * ('a ->  State<'b, 'state>) -> State<'b, 'state>
    abstract Return : 'a -> State<'a, 'state>
    abstract Delay : f:(unit -> State<'a, 'state>) -> State<'a, 'state>
    abstract Map :  ('a -> 'b) * State<'a,'c> -> State<'b,'c>
    abstract Join :  State<State<'a,'b>,'b> -> State<'a,'b>
    abstract Sequence : State<'a,'state> list  ->  State<'a list,'state>
    abstract MapM : ('a -> State<'b,'state>) * 'a list ->  State<'b list,'state>
    abstract Sequence_ : State<'a,'state> list  ->  State<unit,'state>
    abstract MapM_ : ('a -> State<'b,'state>) * 'a list ->  State<unit,'state>
 end

 let run (State f) s = f s

 type StateBuilder() = class end
    with interface IStateMonad with
                member s.Bind(a, f) = let f state =  let (r, s) = run a state
                                                     run (f r) s
                                      State f
                member s.Let(a, f) = f a
                member s.Return a = State (fun state -> (a, state))
                member s.Delay f = f()
                member s.Map(f, m) =  (s:>IStateMonad) { let! a = m
                                                         return f a
                                                       }
                member s.Join(m) =  (s:>IStateMonad).Bind(m, id)
                member s.Sequence(m) = List.foldBack (fun e acc -> (s:>IStateMonad) {   let! e' = e
                                                                                        let! acc' = acc
                                                                                        return (e' :: acc')
                                                                                    } ) m ((s:>IStateMonad).Return([]))
                member s.MapM(f, m) = (s:>IStateMonad).Sequence(List.map f m)
                member s.Sequence_(m) = List.foldBack (fun e acc -> (s:>IStateMonad) {  let! e' = e
                                                                                        let! acc' = acc
                                                                                        return acc'
                                                                                    } ) m ((s:>IStateMonad).Return(()))
                member s.MapM_(f, m) = (s:>IStateMonad).Sequence_(List.map f m)
 
 let stateM = new StateBuilder() :> IStateMonad
   
 let get = State (fun state -> (state, state))
 let set newState = State (fun _ -> ((), newState))
 let modify f = State (fun s -> ((), f s))
 let retreiveState = snd
     
 let mapState f m = State (fun (s:'s) -> f (run m s))

 let withState f m = State (fun (s:'s) -> run m (f s))


// Writer

module WriterM =

 open Monoid
 
 type Writer<'a, 's> = Writer of ('a * 's)
 
  type IWriterMonad<'s> = interface
    abstract Bind : Writer<'a, 's> * ('a ->  Writer<'b, 's>) -> Writer<'b, 's>
    abstract Let :  'a * ('a ->  Writer<'b, 's>) -> Writer<'b, 's>
    abstract Return : 'a -> Writer<'a, 's>
    abstract Delay : f:(unit -> Writer<'a, 's>) -> Writer<'a, 's>
    abstract Sequence :  Writer<'a, 's> list  ->   Writer<'a list, 's>
    abstract MapM : ('a -> Writer<'b, 's>) * 'a list ->  Writer<'b list, 's>
    abstract Sequence_ :  Writer<'a, 's> list  ->  Writer<unit, 's>
    abstract MapM_ : ('a ->  Writer<'b, 's>) * 'a list ->  Writer<unit, 's>
    abstract RunM :  Writer<'a, 'b> -> ('a * 'b)
    abstract Tell : 'a -> Writer<unit, 'a>
    abstract Listen : Writer<'a, 'b> ->  Writer<('a * 'b), 'b>
    abstract Pass :  Writer<('a * ('b -> 'c)), 'b> ->  Writer<'a, 'c>
    abstract MapWriter : (('a * 'b) -> ('c * 'd)) -> ( (Writer<'a, 'b>) -> Writer<'c, 'd>)
    abstract Fmap : ('a -> 'b) -> (Writer<'a, 'c> -> Writer<'b, 'c>)
    abstract Write : 'a -> Writer<unit, 'a>
 end

 //let run (Writer x ) = x
 
 type WriterBuilder<'s>(monoid : Monoid<'s>) = class end
    with interface IWriterMonad<'s> with
                member s.Bind(a, f) = let (v, st) = (s:>IWriterMonad<'s>).RunM a
                                      let (v', st') = (s:>IWriterMonad<'s>).RunM (f v)
                                      Writer (v', monoid.Append st st')
                member s.Let(a, f) = f a
                member s.Return a = Writer (a, monoid.Empty() )
                member s.Delay f = f()
                member s.Sequence(m) = List.foldBack (fun e acc -> (s:>IWriterMonad<'s>) {  let! e' = e
                                                                                            let! acc' = acc
                                                                                            return (e' :: acc')
                                                                                         } ) m ((s:>IWriterMonad<'s>).Return([]))
                member s.MapM(f, m) = (s:>IWriterMonad<'s>).Sequence(List.map f m)
                member s.Sequence_(m) = List.foldBack (fun e acc -> (s:>IWriterMonad<'s>) { let! e' = e
                                                                                            let! acc' = acc
                                                                                            return acc'
                                                                                          } ) m ((s:>IWriterMonad<'s>).Return(()))
                member s.MapM_(f, m) = (s:>IWriterMonad<'s>).Sequence_(List.map f m)
                member s.RunM m = let (Writer x ) = m in x
                member s.Tell a = Writer ((), a)
                member s.Listen m = Writer ( let (a, s) = (s:>IWriterMonad<'s>).RunM m 
                                             ((a, s), s))
                member s.Pass m = Writer ( let ((a, f), s) = (s:>IWriterMonad<'s>).RunM m 
                                           (a, f s))
                member s.MapWriter f = fun m -> Writer (f ((s:>IWriterMonad<'s>).RunM m))
                member s.Fmap f = fun m -> Writer (let (a, w) = (s:>IWriterMonad<'s>).RunM m 
                                                   (f a, w))
                member s.Write v =  Writer ((), v) 


 
 let writerM (monoid : Monoid<'s>) = new WriterBuilder<'s>(monoid) :> IWriterMonad<'s>

 (*let tell   s = Writer ((), s)
 let listen m = Writer ( let (a, s) = run m 
                         ((a, s), s))
 let pass   m = Writer ( let ((a, f), s) = run m 
                         (a, f s))

 let mapWriter f m = Writer (f (run m))

 let fmap f m = Writer (let (a, w) = run m 
                        (f a, w))

 let write v = Writer ((), v) 
 *)

// Reader


module ReaderM =

 type Reader<'a, 'env> = ReaderT of ('env -> 'a)
 with 
    static member Ask() : Reader<'a, 'a> =  ReaderT id 
    static member RunM m = let (ReaderT f) = m in (fun s -> f s)
    static member Fmap f = fun m -> ReaderT (fun st -> f (Reader<_, _>.RunM m st) ) 
    static member Local f = fun m -> ReaderT (fun st -> Reader<_, _>.RunM m (f st))
 end
    

 type IReaderMonad = interface
    abstract Bind : Reader<'a, 's> * ('a ->  Reader<'b, 's>) -> Reader<'b, 's>
    abstract Let :  'a * ('a ->  Reader<'b, 's>) -> Reader<'b, 's>
    abstract Return : 'a -> Reader<'a, 's>
    abstract Delay : f:(unit -> Reader<'a, 's>) -> Reader<'a, 's>
    abstract Asks : ('a -> 'b) -> Reader<'b,'a>
    abstract Sequence :  Reader<'a, 's> list  ->   Reader<'a list, 's>
    abstract MapM : ('a -> Reader<'b, 's>) * 'a list ->  Reader<'b list, 's>
    abstract Sequence_ :  Reader<'a, 's> list  ->  Reader<unit, 's>
    abstract MapM_ : ('a ->  Reader<'b, 's>) * 'a list ->  Reader<unit, 's>
//    abstract RunM : Reader<'a, 's> -> ('s -> 'a)
 //   abstract Fmap : ('a -> 'b) -> ( Reader<'a, 'c> ->  Reader<'b, 'c>)
  //  abstract Local : ('a -> 'b) -> ( Reader<'c, 'b> ->  Reader<'c, 'a>)
//    abstract Ask : Reader<'a, 'a>
 end

 

 //let f() = let t = Reader.Ask<int>() in t

 //let g= f()

 //let (ask:Reader<'a, 'a>) = Reader.Ask
 
(*
 let run (Reader f) s = f s
 
 let mapReader f m = Reader (fun s -> f (run m s))

 let withReader f m = Reader (fun s -> run m (f s))

 let fmap f m = mapReader f m

 let ask = Reader id

 let local f m = withReader f m
 *)

 type ReaderBuilder() = class end
    with interface IReaderMonad with
                member s.Bind(a, f) = ReaderT (fun st -> Reader<_, _>.RunM (f ( Reader<_, _>.RunM a st)) st)
                member s.Let(a, f) = f a
                member s.Return a = ReaderT (fun _ -> a)
                member s.Delay f = f() 
                member s.Asks  sel  = (s:>IReaderMonad) { let! v = Reader<_, _>.Ask() 
                                                          return (sel v)
                                                        }
                member s.Sequence(m) = List.foldBack (fun e acc -> (s:>IReaderMonad) {  let! e' = e
                                                                                        let! acc' = acc
                                                                                        return (e' :: acc')
                                                                                     } ) m ((s:>IReaderMonad).Return([]))
                member s.MapM(f, m) = (s:>IReaderMonad).Sequence(List.map f m)
                member s.Sequence_(m) = List.foldBack (fun e acc -> (s:>IReaderMonad) { let! e' = e
                                                                                        let! acc' = acc
                                                                                        return acc'
                                                                                      } ) m ((s:>IReaderMonad).Return(()))
                member s.MapM_(f, m) = (s:>IReaderMonad).Sequence_(List.map f m)


 let readerM = new ReaderBuilder() :> IReaderMonad
   

// Error Monad

module ErrorM =

 type Either<'l, 'r> = 
    |Right of 'r
    |Left of 'l

 type IErrorMonad = interface
    abstract Bind : Either<'l, 'r1> * ('r1 ->  Either<'l, 'r2>) -> Either<'l, 'r2>
    abstract Let : 'r1 * ('r1 ->  Either<'l, 'r2>) -> Either<'l, 'r2>
    abstract Return : 'r -> Either<'l, 'r>
    abstract Delay : f:(unit -> Either<'l, 'r>) -> Either<'l, 'r>
    abstract Combine : Either<'l, 'r> * Either<'l, 'r> -> Either<'l, 'r>
    abstract Zero : unit -> Either<'l, unit>    
    abstract Map : ('a -> 'b) * Either<'c,'a> -> Either<'c,'b>
    abstract Sequence :  Either<'l, 'r> list -> Either<'l, 'r list>
    abstract MapM : ('a -> Either<'l, 'b>) * 'a list ->  Either<'l, 'b list>
    abstract Sequence_ : Either<'l, 'r> list -> Either<'l, unit>
    abstract MapM_ : ('a ->  Either<'l, 'b>) * 'a list ->  Either<'l, unit>
 end

 
 let throwError e = Left e

 let catch m handler = 
    match m with
    |Right _ -> m
    |Left e -> handler e

 type ErrorBuilder() = class end
    with interface IErrorMonad with
                member s.Bind(a, f) =   match a with 
                                        |Right x -> f x
                                        |Left x -> Left x
                member s.Let(a, f) = f a
                member s.Return a = Right a
                member s.Delay f = f()
                member s.Combine(m1, m2) =  match m1 with
                                            |Right x -> m2
                                            |Left x -> m1
                member s.Zero() = Right ()
                member s.Map(f, m) =  (s:>IErrorMonad) { let! a = m
                                                         return f a
                                                       }
                member s.Sequence(m) = List.foldBack (fun e acc -> (s:>IErrorMonad)  {  let! e' = e
                                                                                        let! acc' = acc
                                                                                        return (e' :: acc')
                                                                                     } ) m ((s:>IErrorMonad).Return([]))
                member s.MapM(f, m) = (s:>IErrorMonad).Sequence(List.map f m)
                member s.Sequence_(m) = List.foldBack (fun e acc -> (s:>IErrorMonad)  { let! e' = e
                                                                                        let! acc' = acc
                                                                                        return acc'
                                                                                      } ) m ((s:>IErrorMonad).Return(()))
                member s.MapM_(f, m) = (s:>IErrorMonad).Sequence_(List.map f m)
    

 let errorM = new ErrorBuilder() :> IErrorMonad


// continuation 


module ContM =

 type Cont<'a, 'r> = Cont of (('a -> 'r) ->'r)

 let run (Cont f) a = f a

 type IContinuationMonad = interface
    abstract Bind : Cont<'a, 'b> * ('a -> Cont<'c, 'b>) -> Cont<'c, 'b>
    abstract Let : 'a * ('a ->  Cont<'a, 'b>) -> Cont<'a, 'b>
    abstract Return : 'a -> Cont<'a, 'b>
    abstract Delay : f:(unit ->  Cont<'a, 'b>) ->  Cont<'a, 'b>
 end
 
 let mapCont f m = Cont (fun k -> f (run m k)) 

 let withCont f m = Cont (fun k -> run m ( f k)) 

 let fmap f m = Cont (fun k -> run m ( fun x -> k (f x))) 

 let callCC f = Cont (fun k -> run (f (fun k1 -> Cont (fun _ -> k k1))) k)

 type ContinuationBuilder() = class end
   with interface IContinuationMonad with
                member s.Bind(a, f) = Cont (fun k -> let (Cont c) = a
                                                     c (fun a -> run (f a) k))
                member s.Let(a, f) = f a
                member s.Return(a) = Cont (fun k -> k a)
                member s.Delay f  = Cont (fun k -> run (f ()) k)
 
 let contM = new ContinuationBuilder() :> IContinuationMonad


